unit Progress;

interface

uses WinTypes, WinProcs, Messages, Classes, Forms, Controls, Buttons,
  StdCtrls, ExtCtrls, MForms, ComCtrls, StrHlder;

type
  TDetectProgress = (dpNone, dpWait, dpWaitProgress, dpProgress);
  TProgressStyle = (psAbortBtn, psWaitMouse, psWaitText, psHideProgress, psOnlyWait);
  TProgressStyles = set of TProgressStyle;
  TProgressForm = class(TForm)
    shProgress: TStrHolder;
    Panel1: TPanel;
    lProgress: TLabel;
    pbProgress: TProgressBar;
    bbAbort: TBitBtn;
    procedure FormCreate(Sender: TObject);
    procedure bbAbortClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormShow(Sender: TObject);
    procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    FStyle: TProgressStyles;
    FWindowList: Pointer;
    function GetWaitText: string;
    procedure SetWaitText(const Value: string);
  public
    property WaitText: string read GetWaitText write SetWaitText;
  end;

procedure ShowProgress(AStyle: TProgressStyles; const AText: string;
  AMax, AProgress: Longint);
procedure BeginWait;
procedure EndWait;
procedure UpdateProgress(const AText: string; AProgress: Longint);
procedure DeltaProgress(const AText: string; ADelta: Longint);
procedure SetProgressMax(AMax: Longint);
function GetProgress: Longint;
function GetProgressMax: Longint;
procedure HideProgress;
function ProgressBreak: Boolean;
function DetectProgress: TDetectProgress;
procedure ProgressYield(const AText: string; ADelta: Longint);

implementation

uses SysUtils, BrkWait, Tools, FastStrings;

{$R *.DFM}

var
  ProgressList: TList;
  ProgressForm: TProgressForm;
  ProgressBrk: Boolean;
  WaitForm: TProgressForm;
  WaitFlag: Integer;
  x_previous, y_previous: integer;                  // .silent

type
  TDummy = class(TCustomControl)
  private
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  protected
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure TDummy.WMSetFocus(var Message: TWMSetFocus);
begin
  Cursor := Screen.Cursor;
  MouseCapture := True;
  Screen.Cursor := crHourGlass;
  inherited;
end;

procedure TDummy.WMKillFocus(var Message: TWMKillFocus);
begin
  MouseCapture := False;
  if Screen.Cursor = crHourGlass then
    Screen.Cursor := Cursor;
  inherited;
end;

procedure TDummy.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  MouseCapture := True;
  Screen.Cursor := crHourGlass;
end;

procedure TDummy.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  MouseCapture := True;
  Screen.Cursor := crHourGlass;
end;

constructor TDummy.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 0;
  Height := 0;
end;

{ TProgressForm }

procedure TProgressForm.FormCreate(Sender: TObject);
var
  Dummy: TDummy;
begin
  FillLanguage(Self, shProgress);
  bbAbort.Cancel := True;
  Dummy := TDummy.Create(Self);
  Dummy.Parent := Self;
  ActiveControl := Dummy;

  KeyPreview := true;                  // by .silent
end;

procedure TProgressForm.FormShow(Sender: TObject);
begin
{  if psWaitMouse in FStyle then
    BeginCursor(crHourGlass);}
  if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  ReleaseCapture;
  if Screen.FormCount > 0 then
    FWindowList := DisableTaskWindows(Handle);
end;

procedure TProgressForm.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
{  if psWaitMouse in FStyle then
    EndCursor(crDefault);}
  if FWindowList <> nil then
  begin
    EnableTaskWindows(FWindowList);
    FWindowList := nil;
  end;
  Action := caHide;
end;

procedure TProgressForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ((ssAlt in Shift) and (Key = VK_F4)) then Key := 0;      // by .silent
  if ((Key = VK_CANCEL) or ((ssCtrl in Shift) and (Key = Ord('C')))) and
    (ExecuteForm(TBreakWaitForm) = mrAbort) then
    ProgressBrk := True;
end;

function TProgressForm.GetWaitText: string;
begin
  Result := lProgress.Caption;
end;

procedure TProgressForm.SetWaitText(const Value: string);
begin
  with lProgress do
    if Caption <> Value then
    begin
      Caption := FastReplace(
                   MinimizeCaption(Value, Canvas, Width, [' ', ',']),
                   '&', '&&', false);
      Update;
    end;
end;

procedure TProgressForm.bbAbortClick(Sender: TObject);
begin
  ProgressBrk := True;
end;

procedure ShowProgress(AStyle: TProgressStyles;
  const AText: string; AMax, AProgress: Longint);

  procedure DoPrev(F: TProgressForm); far;
  begin
    with F do
    begin
//      SetupLanguage(F, shProgress);
      FStyle := AStyle;
      bbAbort.Visible := psAbortBtn in FStyle;
      if psOnlyWait in FStyle then
        Include(FStyle, psWaitMouse);
      if not (psWaitMouse in FStyle) then
        ActiveControl := nil;
      if psHideProgress in FStyle then
      begin
        pbProgress.Visible := False;
        lProgress.Top := lProgress.Top + lProgress.Height;
      end
      else begin
        pbProgress.Position := AProgress;
        pbProgress.Max := AMax;
      end;
      if psWaitText in FStyle then
        WaitText := AText;
      if bbAbort.Visible then
        ActiveControl := bbAbort;
      if psOnlyWait in FStyle then
      begin
        BorderStyle := bsNone;
        Width := 0;
        Height := 0;
      end else
        if not(psAbortBtn in FStyle) then
        begin
          Height := Height - 30;
        end;
    end;
  end;

begin
  if (ProgressList.Count = 0) and not Assigned(WaitForm) then
    ProgressBrk := False;
  ExecutePrev := @DoPrev;
  if not (psOnlyWait in AStyle) then
  begin
    ProgressForm := ShowForm(TProgressForm) as TProgressForm;
    ProgressList.Add(ProgressForm);
    ProgressForm.Update;
  end
  else WaitForm := ShowForm(TProgressForm) as TProgressForm;
end;

procedure BeginWait;
begin
  if (WaitFlag >= 0) and not Assigned(WaitForm) and
    (ProgressList.Count = 0) then
    ShowProgress([psOnlyWait], '', 0, 0);
  Inc(WaitFlag);
end;

procedure EndWait;
begin
  Dec(WaitFlag);
  if WaitFlag = 0 then
    if Assigned(WaitForm) then
      with WaitForm do
      begin
        if Visible then
          Close;
        Free;
        WaitForm := nil;
      end;
end;

procedure UpdateProgress(const AText: string; AProgress: Longint);
begin
  with ProgressForm do
  begin
    if (psWaitText in FStyle) and (AText <> '') then
      WaitText := AText;
    pbProgress.Position := AProgress;
  end;
end;

procedure DeltaProgress(const AText: string; ADelta: Longint);
begin
  with ProgressForm do
  begin
    if (psWaitText in FStyle) and (AText <> '') then
      WaitText := AText;
    pbProgress.Position := pbProgress.Position + ADelta;
  end;
end;

procedure SetProgressMax(AMax: Longint);
begin
  ProgressForm.pbProgress.Max := AMax;
end;

function GetProgress: Longint;
begin
  Result := ProgressForm.pbProgress.Position;
end;

function GetProgressMax: Longint;
begin
  Result := ProgressForm.pbProgress.Max;
end;

procedure HideProgress;
var
  Form: TProgressForm;
begin
  Form := ProgressForm;
  with ProgressList do
  begin
    if Count > 0 then
      Remove(ProgressForm);
    if Count > 0 then
      ProgressForm := Last else
      ProgressForm := nil;
  end;
  if Assigned(Form) then
    with Form do
    begin
      if Visible then
        Close;
      Free;
    end;
  if (ProgressList.Count = 0) and (WaitFlag > 0) then
  begin
    BeginWait;
    EndWait;
  end;
end;

function ProgressBreak: Boolean;
begin
  Result := Application.Terminated or ProgressBrk;
end;

function DetectProgress: TDetectProgress;
begin
  Result := dpNone;
  if ProgressList.Count > 0 then
  begin
    if psAbortBtn in ProgressForm.FStyle then
      Result := dpProgress else
      Result := dpWaitProgress;
  end
  else if Assigned(WaitForm) then
    Result := dpWait;
end;

procedure ProgressYield(const AText: string; ADelta: Longint);
begin
  if DetectProgress <> dpNone then
  begin
    DeltaProgress(AText, ADelta);
    Application.ProcessMessages;
    if ProgressBreak then
      Abort;
  end;
end;

procedure FreeProgress; far;
begin
  ProgressList.Free;
  ProgressList := nil;
end;

procedure TProgressForm.Panel1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then                          // .silent
  begin
    ProgressForm.Left := ProgressForm.Left + x - x_previous;
    ProgressForm.Top := ProgressForm.Top + y - y_previous;
  end;
end;

procedure TProgressForm.Panel1MouseDown(Sender: TObject;                   // .silent
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  x_previous := x;
  y_previous := y;
end;

initialization
  ProgressList := TList.Create;
  AddExitProc(FreeProgress);
end.
